home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.006 / xemacs-1 / lib / xemacs-19.13 / lisp / gnus / gnus-xemacs.el < prev    next >
Encoding:
Text File  |  1995-07-11  |  15.3 KB  |  418 lines
  1. ;;; Mouse, font and toolbar support for GNUS running in XEmacs
  2. ;; Copyright (C) 1992, 1993, 1994 Free Software Foundation, Inc.
  3. ;; Copyright (C) 1995 Richard Cognot
  4.  
  5. ;; This file is part of XEmacs.
  6.  
  7. ;; XEmacs is free software; you can redistribute it and/or modify it
  8. ;; under the terms of the GNU General Public License as published by
  9. ;; the Free Software Foundation; either version 2, or (at your option)
  10. ;; any later version.
  11.  
  12. ;; XEmacs is distributed in the hope that it will be useful, but
  13. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  14. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. ;; General Public License for more details.
  16.  
  17. ;; You should have received a copy of the GNU General Public License
  18. ;; along with XEmacs; see the file COPYING.  If not, write to the Free
  19. ;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  20.  
  21. ;; Richard Cognot provided the toolbar support:
  22. ;;     Right now, no down or disabled icons are provided, but just
  23. ;;     adding them to the icon directory will be enough for them to
  24. ;;     be loaded.  Context-sensitive setting of up/down/inactive
  25. ;;     icons not done.
  26.  
  27. ;;; Right button pops up a menu of commands in Newsgroup and Summary buffers.
  28. ;;; Middle button selects indicated newsgroup or article.
  29.  
  30. (defvar gnus-summary-menu
  31.   '("GNUS Summary Commands"
  32.     ["Select Article / Next Page" gnus-summary-next-page t]
  33.     ["Prev Page" gnus-summary-prev-page t]
  34.     ["Select Parent Article" gnus-summary-refer-parent-article t]
  35.     "----"
  36.     ["Beginning of Article" gnus-summary-beginning-of-article t]
  37.     ["End of Article" gnus-summary-end-of-article t]
  38.     ["Show All Headers" gnus-summary-show-all-headers t]
  39.     ["ROT13 Article" gnus-summary-caesar-message t]
  40.     ["Save Article to Mail File" gnus-summary-save-in-mail t]
  41.     ("Sort Articles"
  42.      ["Sort By Author" gnus-summary-sort-by-author t]
  43.      ["Sort By Date" gnus-summary-sort-by-date t]
  44.      ["Sort By Number" gnus-summary-sort-by-number t]
  45.      ["Sort By Subject" gnus-summary-sort-by-subject t])
  46.     "----"
  47.     ["Mail Reply" gnus-summary-reply t]
  48.     ["Mail Reply (Citing Original)" gnus-summary-reply-with-original t]
  49.     ["Post Reply" gnus-summary-followup t]
  50.     ["Post Reply (Citing Original)" gnus-summary-followup-with-original t]
  51.     ["Post New Article" gnus-summary-post-news t]
  52.     ["Forward Article" gnus-summary-mail-forward t]
  53.     "----"
  54.     ["Show Toolbar" (gnus-toggle-toolbar gnus-summary-toolbar)
  55.      :style toggle :selected (gnus-toolbar-active)]
  56.     "----"
  57.     ["Mark Article as Read" gnus-summary-mark-as-read-forward t]
  58.     ["Mark Article as Unread" gnus-summary-mark-as-unread-backward t]
  59.     ["Mark Similar Subjects as Read" gnus-summary-kill-same-subject t]
  60.     ["Quit this Newsgroup" gnus-summary-exit t]
  61.     ["Quit this Newsgroup (mark everything as read)"
  62.      gnus-summary-catchup-and-exit t]
  63.     ))
  64.  
  65. (defvar gnus-group-menu
  66.   '("GNUS Group Commands"
  67.     ["Select Newsgroup" gnus-group-read-group t]
  68.     ["Unsubscribe Newsgroup" gnus-group-unsubscribe-current-group t]
  69.     ["Get New News" gnus-group-get-new-news t]
  70.     "----"
  71.     ["Mark Newsgroup as Read" gnus-group-catchup t]
  72.     ["Mark All Newsgroups as Read" gnus-group-catchup-all t]
  73.     ["Show All Newsgroups" gnus-group-list-all-groups t]
  74.     ["Show Subscribed Nonempty Newsgroups" gnus-group-list-groups t]
  75.     ["Check Bogosity" gnus-group-check-bogus-groups t]
  76.     "----"
  77.     ["Post New Article" gnus-group-post-news t]
  78.     "----"
  79.     ["Show Toolbar" (gnus-toggle-toolbar gnus-groups-toolbar)
  80.      :style toggle :selected (gnus-toolbar-active)]
  81.     "----"
  82.     ["Save .newsrc" gnus-group-force-update t]
  83.     ["GNUS Manual" gnus-info-find-node t]
  84.     ["Suspend GNUS" gnus-group-suspend t]
  85.     ["Quit GNUS" gnus-group-exit t]
  86.     ))
  87.  
  88. (defvar gnus-article-menu 
  89.   '("GNUS Article Commands"
  90.     ["Next Page" gnus-article-next-page t]
  91.     ["Previous Page" gnus-article-prev-page t]
  92.     ["Pop Article History" gnus-article-pop-article t]
  93.     ["Show Referenced Article" gnus-article-refer-article t]
  94.     ["Show Summary" gnus-article-show-summary t]
  95.     "----"
  96.     ["Mail Reply" gnus-summary-reply t]
  97.     ["Mail Reply (Citing Original)" gnus-summary-reply-with-original t]
  98.     ["Post Reply" gnus-summary-followup t]
  99.     ["Post Reply (Citing Original)" gnus-summary-followup-with-original t]
  100.     ["Forward Article" gnus-summary-mail-forward t]
  101.     ))
  102.  
  103. (defun gnus-summary-menu (e)
  104.   (interactive "e")
  105.   (mouse-set-point e)
  106.   (beginning-of-line)
  107.   (search-forward ":" nil t)
  108.   (popup-menu gnus-summary-menu))
  109.  
  110. (defun gnus-group-menu (e)
  111.   (interactive "e")
  112.   (mouse-set-point e)
  113.   (beginning-of-line)
  114.   (search-forward ":" nil t)
  115.   (popup-menu gnus-group-menu))
  116.  
  117. (defun gnus-article-menu (e)
  118.   (interactive "@e")
  119.   (popup-menu gnus-article-menu))
  120.  
  121. (defun gnus-group-mouse-read-group (e)
  122.   (interactive "e")
  123.   (mouse-set-point e)
  124.   (beginning-of-line)
  125.   (search-forward ":" nil t)
  126.   (gnus-group-read-group nil))
  127.  
  128. (defun gnus-summary-mouse-next-page (e)
  129.   (interactive "e")
  130.   (mouse-set-point e)
  131.   (beginning-of-line)
  132.   (search-forward ":" nil t)
  133.   (gnus-summary-next-page nil))
  134.  
  135. (define-key gnus-summary-mode-map 'button2 'gnus-summary-mouse-next-page)
  136. (define-key gnus-group-mode-map   'button2 'gnus-group-mouse-read-group)
  137.  
  138. (define-key gnus-summary-mode-map 'button3 'gnus-summary-menu)
  139. (define-key gnus-group-mode-map   'button3 'gnus-group-menu)
  140. (define-key gnus-article-mode-map 'button3 'gnus-article-menu)
  141.  
  142.  
  143. ;;; Put message headers in boldface, etc...
  144.  
  145. (require 'highlight-headers)
  146.  
  147. (defun gnus-fontify-headers ()
  148.   (save-excursion
  149.     (set-buffer gnus-article-buffer)
  150.     (save-excursion
  151.       (save-restriction
  152.     (widen)
  153.     (highlight-headers (point-min) (point-max) t)))))
  154.  
  155. (make-face 'gnus-underline)
  156. (or (face-differs-from-default-p 'gnus-underline)
  157.     (set-face-underline-p 'gnus-underline t))
  158.  
  159. (defun gnus-hack-underlining ()
  160.   "replaces underscore-backspace with an extent.
  161. Also removes the extra blank lines from the article."
  162.   (save-excursion
  163.     (set-buffer gnus-article-buffer)
  164.     (goto-char (point-min))
  165.     (while (re-search-forward "\\(\\(_\^H.\\) ?\\)+" nil t)
  166.       (set-extent-face (make-extent (match-beginning 0) (match-end 0))
  167.                'gnus-underline))
  168.     (goto-char (point-min))
  169.     (while (re-search-forward "_\^H" nil t) (replace-match ""))))
  170.  
  171. (defun gnus-hack-clarinews ()
  172.   (if (string-match "^clari\\.*\\|^biz\\.clarinet" gnus-newsgroup-name)
  173.       (save-excursion
  174.     (gnus-hack-underlining)
  175.     (set-buffer gnus-article-buffer)
  176.     (goto-char (point-min))
  177.         (while (re-search-forward "\n\n\n\n*" nil t)
  178.           (replace-match "\n\n")))))
  179.  
  180. (add-hook 'gnus-select-article-hook 'gnus-fontify-headers)
  181. (add-hook 'gnus-article-prepare-hook 'gnus-hack-clarinews)
  182.  
  183.  
  184. ;;; Fontify the Newsgroups and Summary buffers
  185. ;;; Enable this either of these by turning on font-lock-mode:
  186. ;;;
  187. ;;;    (add-hook 'gnus-group-mode-hook   'turn-on-font-lock)
  188. ;;;    (add-hook 'gnus-summary-mode-hook 'turn-on-font-lock)
  189. ;;;
  190. ;;; Fontifying the *Newsgroups* buffer makes `gnus-group-list-all-groups'
  191. ;;; be awfully slow (about 50 seconds to display 2782 groups on a Sparc10.)
  192. ;;; But it's fairly fast for day-to-day use if you only subscribe to a few
  193. ;;; hundred newsgroups.
  194. ;;;
  195. ;;; Fontifying the *Summary* buffer is about the same speed (per line) as
  196. ;;; the *Newsgroups* buffer, but since it's rare to ever select more than
  197. ;;; a few hundred articles, it's not so bad. (For ~100 articles it only 
  198. ;;; takes ~2 seconds.)
  199. ;;;
  200. ;;; Possibly this could be optimized by doing the same sort of trick that
  201. ;;; we did with dired-indent-rigidly (that is, inhibit the after-change-
  202. ;;; function until the whole buffer has been generated) but preliminary
  203. ;;; tests suggest that what this would actually save is negligible.
  204.  
  205. (defconst gnus-summary-font-lock-keywords
  206.   '(
  207.     ;; This is how you put the article number in another face
  208.     ;;("^..[^0-9*]*\\([0-9]+\\):"
  209.     ;; 1 message-highlighted-header-contents)
  210.     ;; This matches the part between [] after optional something-digits-colon
  211.     ("^[^[]+\\[\\([^A-Za-z\n]*[0-9]+:\\)?\\([^[\n]*\\)\\]"
  212.      2 message-headers)
  213.     ;; This matches the part after the first ]
  214.     ("^[^]\n]+\\]\\(.*\\)" 1 message-header-contents)
  215.     ))
  216.  
  217. (defconst gnus-group-font-lock-keywords
  218.   '(
  219.     ;; This is how you put the number of  articles in another face
  220.     ;;("^..[^0-9*]*\\([0-9]+\\):" 1 message-headers)
  221.     ;; This matches the part after the first :
  222.     (": \\(.*\\)" 1 message-header-contents)
  223.     ))
  224.  
  225. ;;; Highlight the line under the mouse in the Newsgroup and Summary buffers.
  226.  
  227. (defun gnus-install-mouse-tracker ()
  228.   (require 'mode-motion)
  229.   (setq mode-motion-hook 'mode-motion-highlight-line))
  230.  
  231. (add-hook 'gnus-summary-mode-hook 'gnus-install-mouse-tracker)
  232. (add-hook 'gnus-group-mode-hook   'gnus-install-mouse-tracker)
  233.  
  234.  
  235. ;;; Put the GNUS menus in the menubar
  236.  
  237. (defun gnus-install-menubar ()
  238.   (if (and current-menubar (not (assoc "GNUS" current-menubar)))
  239.       (let ((menu (cond ((eq major-mode 'gnus-group-mode) gnus-group-menu)
  240.             ((eq major-mode 'gnus-summary-mode) gnus-summary-menu)
  241.             (t (error "not GNUS Group or Summary mode")))))
  242.     (set-buffer-menubar (copy-sequence current-menubar))
  243.     (add-menu nil "GNUS" (cdr menu)))))
  244.  
  245. (add-hook 'gnus-summary-mode-hook 'gnus-install-menubar)
  246. (add-hook 'gnus-group-mode-hook   'gnus-install-menubar)
  247.  
  248.  
  249. ;;; Setup the GNUS toolbar and associated vars.
  250.  
  251. (defvar gnus-toolbar-icon-directory nil
  252.   "Where the toolbar icons for GNUS are.")
  253.  
  254. (defvar gnus-toolbar-exit-icon nil 
  255.   "Toolbar icon for unsubscribe newsgroup")
  256. (defvar gnus-toolbar-unsubscribe-newsgroup-icon nil 
  257.   "Toolbar icon for unsubscribe newsgroup")
  258. (defvar gnus-toolbar-get-new-news-icon nil 
  259.   "Toolbar icon for unsubscribe newsgroup")
  260. (defvar gnus-toolbar-catchup-newsgroup-icon nil 
  261.   "Toolbar icon for catchup newsgroup")
  262. (defvar gnus-toolbar-read-newsgroup-icon nil 
  263.   "Toolbar icon for read newsgroup")
  264. (defvar gnus-toolbar-next-newsgroup-icon nil 
  265.   "Toolbar icon for next unread newsgroup")
  266. (defvar gnus-toolbar-prev-newsgroup-icon nil 
  267.   "Toolbar icon for previous unread newsgroup")
  268. (defvar gnus-toolbar-next-article-icon nil 
  269.   "Toolbar icon for next unread article")
  270. (defvar gnus-toolbar-prev-article-icon nil 
  271.   "Toolbar icon for previous unread article")
  272. (defvar gnus-toolbar-kill-icon nil 
  273.   "Toolbar icon for kill article")
  274. (defvar gnus-toolbar-kill-thread-icon nil 
  275.   "Toolbar icon for kill thread")
  276. (defvar gnus-toolbar-reply-article-icon nil 
  277.   "Toolbar icon for reply to article")
  278. (defvar gnus-toolbar-followup-article-icon nil 
  279.   "Toolbar icon for followup to article")
  280. (defvar gnus-toolbar-post-article-icon nil 
  281.   "Toolbar icon for post new article")
  282.  
  283. (defvar gnus-toolbar-orientation 'default
  284.   "*Where to put the GNUS toolbar.  Must be one of these symbols:
  285.  
  286. default -- place at location specified by function `default-toolbar-position'
  287. top     -- place along the top of the frame
  288. bottom  -- place along the bottom of the frame
  289. right   -- place along the right edge of the frame
  290. left    -- place along the left edge of the frame
  291. none    -- no toolbar")
  292.  
  293. (defvar gnus-groups-toolbar
  294.   '(
  295.     [gnus-toolbar-exit-icon
  296.      gnus-group-exit t "Exit GNUS"]
  297.     [gnus-toolbar-get-new-news-icon 
  298.      gnus-group-get-new-news t "Get new news"]
  299.     [gnus-toolbar-prev-newsgroup-icon
  300.      gnus-group-prev-unread-group t "Previous unread group"]
  301.     [gnus-toolbar-next-newsgroup-icon
  302.      gnus-group-next-unread-group t "Next unread group"]
  303.     [gnus-toolbar-read-newsgroup-icon
  304.      gnus-group-read-group t "Read current group"]
  305.     [gnus-toolbar-catchup-newsgroup-icon
  306.      gnus-group-catchup t "Catchup current group"]
  307.     [gnus-toolbar-unsubscribe-newsgroup-icon 
  308.      gnus-group-unsubscribe-current-group t "Unsubscribe group"]
  309.    )
  310.   "The toolbar for GNUS summary mode.")
  311.  
  312. (defvar gnus-summary-toolbar
  313.   '(
  314.     [gnus-toolbar-exit-icon
  315.      gnus-summary-exit t "Exit newsgroup"]
  316.     [gnus-toolbar-catchup-newsgroup-icon
  317.      gnus-summary-catchup-and-exit t "Catchup current group"]
  318.     [gnus-toolbar-prev-article-icon
  319.      gnus-summary-prev-unread-article t "Previous unread message"]
  320.     [gnus-toolbar-next-article-icon
  321.      gnus-summary-next-unread-article t "Next unread message"]
  322.     [gnus-toolbar-kill-article-icon 
  323.      gnus-summary-mark-as-read-forward t "Kill article"]
  324.     [gnus-toolbar-kill-thread-icon 
  325.      gnus-summary-kill-same-subject-and-select t "Kill thread"]
  326.     [gnus-toolbar-reply-article-icon 
  327.      gnus-summary-reply-with-original t "Reply to sender"]
  328.     [gnus-toolbar-followup-article-icon 
  329.      gnus-summary-followup-with-original t "Followup"]
  330.     [gnus-toolbar-post-article-icon 
  331.      gnus-summary-post-news t "Post new article"]
  332.    )
  333.   "The toolbar for GNUS summary mode.")
  334.  
  335. (defun gnus-toolbar-active ()
  336.   (interactive)
  337.   (if (featurep 'toolbar)
  338.       (let ((toolbar (gnus-toolbar-from-orientation gnus-toolbar-orientation)))
  339.     (if (specifier-instance toolbar)
  340.         t
  341.       nil))
  342.     nil))
  343.  
  344. (defun gnus-toggle-toolbar (toolbar)
  345.   (interactive)
  346.   (if (featurep 'toolbar)
  347.       (let ((toolbar-obj (gnus-toolbar-from-orientation
  348.               gnus-toolbar-orientation)))
  349.     (if (gnus-toolbar-active)
  350.         (set-specifier toolbar-obj (cons (current-buffer) nil))
  351.       (set-specifier toolbar-obj (cons (current-buffer) toolbar))))))
  352.  
  353. (defun gnus-toolbar-init ()
  354.   "Set up GNUS toolbar"
  355.   (if (not (featurep 'toolbar))
  356.       nil
  357.     (if (not gnus-toolbar-icon-directory)
  358.     (setq gnus-toolbar-icon-directory
  359.           (file-name-as-directory
  360.            (expand-file-name "gnus" data-directory))))
  361.     (if (not (file-exists-p gnus-toolbar-icon-directory))
  362.     (message "Toolbar directory does not exist.")
  363.       (if (fboundp 'toolbar-make-button-list)
  364.       (mapcar
  365.        (function
  366.         (lambda (x)
  367.           (let* ((ext (if (featurep 'xpm) ".xpm" ".xbm"))
  368.              (base gnus-toolbar-icon-directory)
  369.              (up (expand-file-name (concat x "-up" ext) base))
  370.              (dn (expand-file-name (concat x "-dn" ext) base))
  371.              (var (intern (concat "gnus-toolbar-" x "-icon")))
  372.              (no (expand-file-name (concat x "-no" ext) base)))
  373.         (set var
  374.              (cond
  375.               ((and (file-exists-p up) (file-exists-p dn)
  376.                 (file-exists-p no))
  377.                (toolbar-make-button-list up dn no))
  378.               ((file-exists-p up)
  379.                (toolbar-make-button-list up))
  380.               (t nil))))))
  381.        '("exit" "unsubscribe-newsgroup" "get-new-news" "catchup-newsgroup" 
  382.          "read-newsgroup" "next-newsgroup" "prev-newsgroup"
  383.          "next-article" "prev-article" "kill-article" "kill-thread"
  384.          "reply-article" "followup-article" "post-article"))))))
  385.  
  386. (defun gnus-toolbar-from-orientation (orientation)
  387.   (cond
  388.    ((eq 'default gnus-toolbar-orientation) default-toolbar)
  389.    ((eq 'bottom gnus-toolbar-orientation) bottom-toolbar)
  390.    ((eq 'top gnus-toolbar-orientation) top-toolbar)
  391.    ((eq 'left gnus-toolbar-orientation) left-toolbar)
  392.    ((eq 'right gnus-toolbar-orientation) right-toolbar)))
  393.  
  394. (defun gnus-set-toolbar-internal (toolbar)
  395.   (if (not (featurep 'toolbar))
  396.       nil
  397.     (if (not gnus-toolbar-exit-icon)
  398.     (gnus-toolbar-init))
  399.     (if (fboundp 'set-specifier)
  400.     (let ((toolbar-obj
  401.            (gnus-toolbar-from-orientation gnus-toolbar-orientation)))
  402.       (if toolbar-obj
  403.           (set-specifier toolbar-obj (cons (current-buffer) toolbar)))))))
  404.  
  405. (defun gnus-toolbar-set-groups-toolbar ()
  406.   "Set GNUS toolbar in group buffer."
  407.   (gnus-set-toolbar-internal gnus-groups-toolbar))
  408.  
  409. (defun gnus-toolbar-set-summary-toolbar ()
  410.   "Set GNUS toolbar in summary buffer."
  411.   (gnus-set-toolbar-internal gnus-summary-toolbar))
  412.  
  413. (add-hook 'gnus-summary-mode-hook 'gnus-toolbar-set-summary-toolbar)
  414. (add-hook 'gnus-group-mode-hook 'gnus-toolbar-set-groups-toolbar)
  415.  
  416.  
  417. (provide 'gnus-xemacs)
  418.